home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / DevTools / debugger.orig < prev    next >
Encoding:
Text File  |  1993-05-11  |  28.8 KB  |  1,262 lines
  1. \ Debugger
  2. \
  3. \ To use this debugger, surround the code you
  4. \ want debugged with debug{ ..... }debug
  5. \ then compile it.  The debugger will compile
  6. \ names embedded in the code.
  7. \ Then enter:   DEBUG  name     to debug a
  8. \ named Forth routine.
  9. \ Enter '?' in debugger for menu.
  10. \
  11. \ For example:
  12. \    DEBUG{
  13. \    : FOO ( -- )
  14. \        23 dup + .
  15. \    ;
  16. \    }DEBUG
  17. \    DEBUG FOO
  18. \
  19. \ Author: Phil Burk
  20. \ Copyright 1988 Phil Burk
  21. \
  22. \ MOD: PLB 8/29/88 Check for second level of interpreter.
  23. \      For LOCALS and other vectorred FINDs.
  24. \      Save Stack, HERE and PAD
  25. \      Don't use Assembler
  26. \ MOD: PLB 9/9/88 Use IF.FORGOTTEN }DEBUG
  27. \ MOD: PLB 9/13/88 Add HERE 256 dump
  28. \ MOD: PLB 11/15/88 Fixed line handling with FILL-TIB?
  29. \      Handle LF chars to allow DEBUG from CLI
  30. \ MOD: PLB 12/7/88 Added 'l' command, added window,
  31. \      removed call to DB.FILL-TIB?
  32. \ MOD: PLB 12/10/88 Display Relative addressing.
  33. \ MOD: PLB 12/15/88 Vector quit to close window.
  34. \ MOD: PLB 1/3/89 Save LASTSCAN before WORD
  35. \      Added multiple breakpoints.
  36. \ MOD: PLB 1/11/89 Cleanup RECURSION check, add DEBUG.RESET
  37. \ MOD: PLB 2/3/89 Save EMIT properly and use FAST I/O, add BYE
  38. \ MOD: PLB 2/7/89 Save HERE and PAD during debug.
  39. \ MOD: PLB 6/6/91 INCLUDE JU:LOCALS so that ';' is before debugger
  40. \        copy name to DB-PAD in DB.FIND
  41. \ MOD: PLB 7/2/91 Do not DB-WINPTR OFF so that windows can
  42. \       be closed with DEBUG.STOP after an error.
  43. \ 00001 18-aug-91  mdh     Incorporated XBLK
  44. \ 00002 PLB 11/14/91 Used $= so JU:LOCALS not needed. Now works
  45. \          with any redefinition of ; EXIT RETURN or ;M
  46. \ 00003 PLB 12/14/91 Fixed BREAKAT when DEBUG{ on by using DB-PAD2
  47. \ 00004 PLB 1/4/92 Fixed BREAKAT for words with locals by
  48. \        adding DB.RETURN.TO.RTS
  49. \ 00005 MDH 5/10/93 Increased db_MAX_NEST to 64 (from 32)
  50.  
  51. decimal
  52. include? tolower ju:char-macros
  53.  
  54. ANEW TASK-DEBUGGER
  55. decimal
  56.  
  57. : SAVE.REGS ( -- )
  58.     [ $ 48e7,fefc , ] inline
  59. ;
  60. : RESTORE.REGS ( -- )
  61.     [ $ 4cdf,3f7f , ] inline
  62. ;
  63.  
  64. : PUSH.REGS ( -- a7-a0/d7-d0 )
  65.     [ $ 2D07 w, \ move.l tos,-(dsp)
  66.       $ 48E6FFFF , \ movem.l d0-d7/a0-a7,-(dsp)
  67.       $ 2E1E w, \ move.l (dsp)+,tos
  68.     ]
  69. ;
  70.  
  71. : .REG  ( reg -- )
  72.     base @ >r HEX
  73.     s->d
  74.     <# # # # #
  75.        # # # # #>
  76.     type
  77.     r> base !
  78. ;
  79. : PRINT.4REGS  ( v4 v3 v2 v1 -- )
  80.     4 0 DO BL i 12 * 4 + emit-to-column .reg LOOP
  81. ;
  82.  
  83. : PRINT.16REGS  ( -- a7-a0/d7-d0 )
  84.     >newline ." Data Registers" cr
  85.     ." D0-3: " print.4regs cr
  86.     ." D4-7: " print.4regs cr
  87.     ." Address Registers" cr
  88.     ." A0-3: " print.4regs cr
  89.     ." A$-7: " print.4regs cr
  90. ;
  91.  
  92. : DUMP.REGS
  93.     save.regs
  94.     push.regs
  95.     print.16regs
  96.     restore.regs
  97. ;
  98.  
  99. \ This next word will be handy for calling from ASM code.
  100. variable db-SAVE-PC
  101. : DUMP.68000 ( -- , show PC & regs )
  102.     r@ >rel db-save-pc !
  103.     save.regs  push.regs
  104.     >newline db-save-pc @ ." PC = " .reg cr
  105.     print.16regs
  106.     restore.regs
  107. ;
  108.  
  109.     
  110. \ ---------------- ALL VARIABLES --------------------
  111. DEFER OLD.FIND
  112. what's find is old.find
  113. defer USER.BREAK?  ( address -- debug? )
  114. ' 0= is user.break?
  115. DEFER db.OLD.QUIT
  116. ' noop is db.old.quit
  117.  
  118. \ Variables used at compile time.
  119. variable db-PAD1 128 allot
  120. variable DB-PAD2 128 allot ( name to search for in BREAKAT 00003 )
  121. variable db-INSTALLED ( vectors installed )
  122. variable db-LATEST  ( save latest to tell when in new word)
  123. variable db-LAST-STATE  ( use to detect state transitions)
  124. variable db-START-STATE ( use to detect debug{ }debug errors )
  125. variable db-ABORT   ( use to avoid recursion in user.break?)
  126. variable db-SIZE-ADDR ( place where instruction size goes )
  127. variable db-CODE-ADDR ( address of code after debug )
  128. variable db-ENABLE  ( allow compilation of debug info )
  129.  
  130. \ Variables used when debugging.
  131. variable db-ACTIVE  ( control whether debug prints )
  132. variable db-TOUCH   ( control whether debug stops )
  133. variable db-GO      ( do another step )
  134. variable db-COUNT   ( only break if zero )
  135. variable db-CURRENT ( address of current step )
  136. variable db-NAME    ( address of current word name )
  137. variable db-DIVE    ( control traversing called words)
  138. variable db-LEVEL   ( level of nesting )
  139. variable db-TRIGGER ( level for debugger to come back )
  140. variable db-GOT-LF  ( getting an LF means in CLI !! )
  141. variable db-OLDCON  ( hold old console, true if dbg window open)
  142. variable db-WINPTR  ( pointer to debugger window )
  143. variable db-OUT     ( hold OUT when in debug )
  144. variable db-SAVE-RP ( save RP as place to jump back to )
  145. variable db-MODE    ( mode for traversing code )
  146. variable db-RESULT  ( result from searches and other things )
  147. variable db-RETPTR  ( return stack pointer at entry )
  148.  
  149. \ Variables used to control Debugger options.
  150. variable db-WINDOW  ( true if use own window )
  151. db-window on
  152. variable db-CHECK^D ( break on ^D if true )
  153. db-check^d on
  154.  
  155. 0 constant db_NORMAL_MODE  ( stop and debug code )
  156. 1 constant db_SEARCH_MODE  ( scan code for instruction )
  157. 2 constant db_ENTRY_MODE   ( find entry point )
  158. 3 constant db_SKIP_MODE    ( skip over code )
  159. \
  160. \ Support multiple breakpoints ---------------------------------
  161. \ Keep breakpoints in a table.
  162. \ Use by scanning for match.
  163. \ Add breakpoint at a zero location.
  164. \ Remove by scanning for match and setting to zero.
  165. 16 constant db_MAX_BREAKS
  166. variable db-NUM-BREAKS
  167. db_max_breaks array db-BREAK-TABLE
  168.  
  169. : NOBREAKS ( -- clear all breakpoints )
  170.     0 db-num-breaks !
  171. ;
  172. nobreaks
  173.  
  174. : DB.MATCH.BREAK  ( value -- index | -1 )
  175.     -1 swap   ( default flag )
  176.     0 db-break-table
  177.     db-num-breaks @ 0
  178.     DO  2dup @ =
  179.         IF >r >r drop i r> r> LEAVE
  180.         THEN cell+  ( fast linear search )
  181.     LOOP 2drop
  182. ;
  183.  
  184. : DB.ADD.BREAK ( value -- )
  185.     db-num-breaks @ db_max_breaks <
  186.     IF dup >newline ." Breakpoint added at " .hex cr
  187.        db-num-breaks @ db-break-table !
  188.        1 db-num-breaks +!
  189.     ELSE drop ." Breakpoint table full!"
  190.     THEN
  191. ;
  192.  
  193. : DB.CLEAR.BREAK ( value -- , remove from table )
  194.     db.match.break dup 0<
  195.     IF drop ."  Breakpoint not set!"
  196.     ELSE ( -- i )
  197.         dup 1+ db-num-breaks @ <
  198.         IF  ( -- i , pack table )
  199.             dup>r 1+ db-break-table  ( -- src )
  200.             dup cell-   ( -- src dst )
  201.             db-num-breaks @ r> - 1- 0 max cells move
  202.         ELSE drop
  203.         THEN
  204.         -1 db-num-breaks +!
  205.     THEN
  206. ;
  207.  
  208. : DB.SHOW.BREAKS ( -- )
  209.     >newline db-num-breaks @ 0
  210.     DO i .hex i db-break-table @ .hex cr
  211.     LOOP
  212. ;
  213.     
  214. \
  215. \ -----------------------------------------------------
  216. \ Calling Sequence Trace Stack
  217. \ This will be needed for CLONED programs that don't
  218. \ have NFAs so UNRAVEL won't work.
  219. 64 constant db_MAX_NEST   \ 00005
  220. db_max_nest array db-CALLS
  221. variable db-SP  ( number of things on stack )
  222. : DB.0SP  ( - , clear debug stack )
  223.     db-sp off
  224. ;
  225.  
  226. : DB.PUSH  ( value -- , push value onto stack )
  227.     db-sp @ db_max_nest <
  228.     IF db-sp @ db-calls !
  229.        1 db-sp +!  ( post increment )
  230.     ELSE drop
  231.        ." db.PUSH - debug stack overflow, nested too deep!" cr
  232.     THEN
  233. ;
  234.  
  235. : DB.TOS ( -- value ,  )
  236.     db-sp @ 1- ( predecrement ) db-calls @
  237. ;
  238.  
  239. : DB.DROP ( -- )
  240.     db-sp @ 0>
  241.     IF -1 db-sp +!
  242. \    ELSE
  243. \       ." db.DROP - already empty debug stack!"
  244.     THEN
  245. ;
  246.  
  247. : DB.POP ( -- value )
  248.     db.tos
  249.     db.drop
  250. ;
  251.  
  252. : DB.SAVE.CALLS ( -- )
  253.     r> ( return address )
  254.     0
  255.     BEGIN dup db-sp @ <
  256.     WHILE dup db-calls @ >r 1+
  257.     REPEAT drop
  258.     db-sp @ >r ( save count )
  259.     >r
  260. ;
  261.  
  262. : DB.RESTORE.CALLS ( -- )
  263.     r> ( return address )
  264.     r> dup db-sp !  ( get count )
  265.     BEGIN dup 0>
  266.     WHILE 1- r> over db-calls  !
  267.     REPEAT drop
  268.     >r
  269. ;
  270.  
  271. : DB.SHOW.CALLS ( -- , assume stack has $names )
  272.     >newline ." Calls: "
  273.     db-sp @ 0
  274.     DO  i 0> IF ."  --> "
  275.         THEN
  276.         i db-calls @ $type cr?
  277.     LOOP
  278. ;
  279.  
  280. : DB.TEST.CALLS ( -- )
  281.     db.0sp
  282.     " SWAP" db.push
  283.     " JABBER" db.push
  284.     " 1+" db.push
  285.     db.show.calls
  286.     db.0sp
  287. ;
  288.  
  289. \ -----------------------------------------------------
  290.  
  291. : DB.VARS.OFF ( -- , reset variables )
  292.     db-active off
  293.     db-count off
  294.     db-current off
  295.     db-dive off
  296.     db-level off
  297.     db-trigger off
  298.     db-abort off
  299.     db-latest off
  300.     db-last-state off
  301.     db-got-lf off
  302. \    db-oldcon off
  303. \    db-winptr off
  304.     db-mode @ off
  305. ;
  306.  
  307. : DB.SAVE.VARS  ( -- , save state )
  308.     r>  ( save return address )
  309.     db-active @ >r
  310.     db-go @ >r
  311.     db-count @ >r
  312.     db-current @ >r
  313.     db-dive @ >r
  314.     db-level @ >r
  315.     db-trigger @ >r
  316. \    db-oldcon @ >r
  317. \    db-winptr @ >r
  318.     db-save-rp @ >r
  319.     db-mode @ >r
  320.     db-retptr @ >r
  321.     db-out @ >r
  322.     db-name @ >r
  323.     db-touch @ >r
  324.     >r  ( restore return address )
  325. ;
  326. : DB.RESTORE.VARS  ( -- , restore state , must match DB.SAVE.VARS )
  327.     r>  ( save return address )
  328.     r> db-touch !
  329.     r> db-name !
  330.     r> db-out !
  331.     r> db-retptr !
  332.     r> db-mode !
  333.     r> db-save-rp !
  334. \    r> db-winptr !
  335. \    r> db-oldcon !
  336.     r> db-trigger !
  337.     r> db-level !
  338.     r> db-dive !
  339.     r> db-current !
  340.     r> db-count !
  341.     r> db-go !
  342.     r> db-active !
  343.     >r  ( restore return address )
  344. ;
  345.  
  346. : DB.SAVE.HERE ( -- , save here and 256 byte on R stack )
  347.     r>  ( save return address )
  348. \ Save HERE and next 256 bytes, saves PAD
  349.     64 0
  350.     BEGIN 2dup >
  351.     WHILE here over cells + @ >r 1+
  352.     REPEAT 2drop
  353.     here >r
  354.     >r ( for RTS )
  355. ;
  356.  
  357. : DB.RESTORE.HERE ( -- , restore HERE )
  358.     r>  ( return address )
  359.     r> HERE - warning" WARNING - HERE and PAD moved!"
  360.     64
  361.     BEGIN dup 0>
  362.     WHILE 1- r> over cells here + !
  363.     REPEAT drop
  364.     >r  ( for RTS )
  365. ;
  366.  
  367. : DB.PAUSE  ( -- , do several lines of forth input )
  368. \ Save data stack on return stack.
  369.     depth 0>
  370.     IF depth dup>r
  371.         xdup r> x>r
  372.     THEN
  373.     depth >r
  374. \
  375. \ Save miscellaneous.
  376.     flushemit  pushtib
  377.     span @ >r
  378.     db.save.calls
  379.     db.save.vars
  380.     db.vars.off
  381.     xblk @ >r ( 00001 )   fblk @ >r  blk @ >r
  382.     xblk off  ( 00001 )   fblk off  blk off  out off
  383. \
  384.     BEGIN cr ." Forth> " query #tib @ 0>
  385.     WHILE interpret
  386.     REPEAT
  387. \
  388.     r> blk !  r> fblk !    r> xblk ! ( 00001 )
  389.     db.restore.vars
  390.     db.restore.calls
  391.     r> span !
  392.     pulltib
  393. \
  394. \ Restore Data Stack
  395.     0sp r> dup 0>
  396.     IF xr>
  397.     ELSE drop
  398.     THEN
  399. ;
  400.  
  401. : DB.INPUT$ ( -- $string )
  402.     span @
  403.     db-pad1 1+
  404.     128 expect
  405.     span @ db-pad1 c!
  406.     span !
  407.     db-pad1
  408. ;
  409.  
  410. : DB.LF.INPUT$ ( -- , skip first LF if in CLI )
  411.     db-got-lf @
  412.     IF db.input$ c@ 0=
  413.        IF db.input$  ( try again )
  414.        ELSE db-pad1
  415.        THEN
  416.     ELSE db.input$
  417.     THEN
  418. ;
  419.  
  420. : DB.INPUT# ( -- N )
  421.     ." #> "
  422.     db.input$
  423.     number?
  424.     IF  dpl @ 0< ( single precision? )
  425.         IF drop
  426.         THEN
  427.     ELSE 0 ." Not valid, 0 used!" cr
  428.     THEN
  429. ;
  430.  
  431. : DB.S  ( -- , print stack )
  432.     >newline
  433.     depth 0<
  434.     IF ." Underflow!" 0sp  ( reset )
  435.     ELSE
  436.         depth 0=
  437.         IF ." Empty!"
  438.         ELSE
  439.             depth 10 >
  440.             IF ." <<<["
  441.             ELSE ." ["
  442.             THEN
  443.             base @ decimal
  444.             depth 1- 1 .r ." ] "
  445.             base !
  446.             depth 8 min 0
  447.             DO depth 8 min i - 1- pick . cr?
  448.             LOOP
  449.         THEN
  450.     THEN
  451. ;
  452.  
  453. : DB.RDEPTH  ( -- #retcells )
  454.     r0 @ db-retptr @ - cell/  20 -
  455.     0 max
  456. ;
  457.  
  458. : DB.RSTACK  ( -- , print return stack )
  459.     >newline
  460.     db.rdepth  10 >
  461.     IF ." <<<("
  462.     ELSE ." ("
  463.     THEN
  464.     base @ decimal
  465.     db.rdepth 1 .r ." ) "
  466.     base !
  467.     db.rdepth dup 30 - 0 max
  468.     DO r0 @  i 5 + cells - @ .hex cr?
  469.     LOOP
  470. ;
  471.  
  472. : DB.GET.SIZE ( -- size )
  473.     db-name @ dup c@ + c@ ascii 0 -
  474. ;
  475.  
  476. : DB.SKIP ( -- skip instruction )
  477.     db.get.size db-save-rp +!
  478. ;
  479.  
  480. \ Window I/O Control
  481. : SWAP.OUT ( -- , swap debugger out for systems )
  482.     out @ db-out @ out ! db-out !
  483. ;
  484.  
  485. defer DB-OLD-EMIT
  486. defer DB-OLD-FLUSHEMIT
  487. variable DB-OLD-FASTIO?
  488.  
  489. : DB.SET.VECTORS ( -- )
  490.     what's db-old-emit ' quit =
  491.     IF  flushemit
  492.         what's emit is db-old-emit
  493.         what's flushemit is db-old-flushemit
  494.         fastio? @ db-old-fastio? !
  495.         fast  ( comment out this line to make debug work with LOGTO )
  496.         ( But there may be problems with users redefining EMIT )
  497.         ( and recursing! )
  498.     THEN
  499. ;
  500.  
  501. : DB.RESET.VECTORS ( -- )
  502.     what's db-old-emit ' quit -
  503.     IF  what's db-old-emit is emit
  504.         what's db-old-flushemit is flushemit
  505.         db-old-fastio? @ fastio? !
  506.         ' quit is db-old-emit
  507.     THEN
  508. ;
  509.     
  510. : DB.WINDOW.ON  ( -- , use debugger window )
  511.     db-winptr @
  512.     IF  db.set.vectors
  513.         db-oldcon @ 0=
  514.         IF  console@ db-oldcon !
  515.             flushemit swap.out
  516.             db-winptr @ console!
  517.         THEN
  518.     THEN
  519. ;
  520.  
  521. : DB.WINDOW.OFF  ( -- , use normal window )
  522.     db-winptr @
  523.     IF  db-oldcon @
  524.         IF  flushemit db-oldcon @ console!
  525.             swap.out  db-oldcon off
  526.         THEN
  527.         db.reset.vectors
  528.     THEN
  529. ;
  530.  
  531. : DB.CLOSE.WINDOW ( -- , close debugger window )
  532.     db-winptr @
  533.     IF  db.window.off
  534.         db-winptr @ fclose
  535.         db-winptr off
  536.     THEN
  537. ;
  538.  
  539. : DB.CLEANUP ( -- )
  540.     db-active off db-trigger off
  541.     db.0sp
  542.     db.close.window
  543.     what's db.old.quit dup ' noop =
  544.     IF drop
  545.     ELSE is quit ' noop is db.old.quit
  546.     THEN 
  547. ;
  548.  
  549. : DB.QUIT ( -- , quit and reset vectors )
  550.     db.cleanup quit
  551. ;
  552.  
  553. : DB.OPEN.WINDOW ( -- , open debugger window )
  554.     db-window @
  555.     db-winptr @ 0= AND
  556.     IF  " RAW:0/20/640/120/JForth Debugger"
  557.         $fopen ?dup
  558.         IF db-winptr !
  559.         ELSE ." Debugger window could not be opened!" cr
  560.         THEN
  561.     THEN
  562.     what's db.old.quit ' noop =
  563.     IF \ Set quit vectors
  564.         what's quit is db.old.quit
  565.         ' db.quit is quit
  566.     THEN
  567. ;
  568.  
  569.  
  570. : WAIT?CR  ( -- , wait if key )
  571.     ?terminal
  572.     IF key drop
  573.         key drop
  574.     THEN cr
  575. ;
  576.  
  577. \ Interactive Command Parsing
  578. : DB.HELP ( -- )
  579.     wait?cr
  580.     ." JForth Debugger - PLB" wait?cr
  581.     ." Information:" wait?cr
  582.     ."   w - Where?, who called who" wait?cr
  583.     ."   6 - 680x0 register dump" wait?cr
  584.     ."   m - Memory dump from address on stack" wait?cr
  585.     ."   s - regular Stack dump" wait?cr
  586.     ."   r - Return stack hex dump" wait?cr
  587.     ."   h - HERE 256 DUMP , shows PAD too" wait?cr
  588.     ." Action:" wait?cr
  589.     ."   f - Forth, interpret one line" wait?cr
  590.     ."   x - drop one number from stack" wait?cr
  591.     ."   n - push a Number onto stack" wait?cr
  592.     ."   + - add a number to top of stack" wait?cr
  593.     ." Bases: 1 - decimal , 2 - binary , 3 - hex" wait?cr
  594.     ." User:  7,8,9 - DEBUG.USER.7,8,9" wait?cr
  595.     ." Control:" cr
  596.     ."   b - set the Breakpoint here" wait?cr
  597.     ."   c - Clear the breakpoint here" wait?cr
  598.     ."   # - enter # breaks to skip" wait?cr
  599.     ."   u - Up, continue until RTS" wait?cr
  600.     ."   j - Jump over next instruction" wait?cr
  601.     ."   z - set user.break? to 0= , disabled" wait?cr
  602.     ."   l - Look at code ?terminal until" wait?cr
  603.     ."   g - Go" wait?cr
  604.     ."   <SPACE> - single step on same level" wait?cr
  605.     ."   <CR> or d - dive down into word" wait?cr
  606.     ."   q - quit" wait?cr
  607. ;
  608.  
  609. defer debug.user.7 ' db.help is debug.user.7
  610. defer debug.user.8 ' db.help is debug.user.8
  611. defer debug.user.9 ' db.help is debug.user.9
  612.  
  613. : DB.PARSE  ( char -- continue? , act on char )
  614.     db-go off
  615.     tolower
  616.     CASE
  617.            $ 0D OF db-dive on db-go on
  618.                 ENDOF
  619.              BL OF db-dive off db-go on
  620.                 ENDOF
  621.         ascii u OF db-active off db-go on
  622.                    db-level @ db-trigger !
  623.                 ENDOF
  624.         ( ^D) 4 OF >newline ." Control-D break!" cr
  625.                 ENDOF
  626.              10 OF ( ignore line feed )
  627.                 ENDOF
  628.         ascii 1 OF decimal  >newline ." Decimal!" ENDOF
  629.         ascii 2 OF 2 base ! >newline ." Binary!"  ENDOF
  630.         ascii 3 OF hex  >newline ." Hexadecimal!" ENDOF
  631.         ascii 6 OF dump.regs ENDOF
  632.         ascii d OF db-dive on db-go on
  633.                 ENDOF
  634.         ascii f OF db.pause >newline
  635.                 ENDOF
  636.         ascii g OF db-active off db-go on
  637.                    db-trigger off
  638.                 ENDOF
  639.         ascii h OF here 256 dump
  640.                 ENDOF
  641.         ascii j OF db.skip ." Instruction Skipped!" db-go on
  642.                 ENDOF
  643.         ascii l OF db-touch off db-go on
  644.                 ENDOF
  645.         ascii m OF dup 32 dump
  646.                 ENDOF
  647.         ascii n OF >newline ." Push " db.input#
  648.                 ENDOF
  649.         ascii r OF db.rstack
  650.                 ENDOF
  651.         ascii s OF .s
  652.                 ENDOF
  653.         ascii w OF db.show.calls
  654.                 ENDOF
  655.         ascii x OF drop
  656.                 ENDOF
  657.         ascii + OF >newline ." Add " db.input# +
  658.                 ENDOF
  659.         ascii b OF db-current @ db.add.break >newline
  660.                 ENDOF
  661.         ascii c OF db-current @ db.clear.break >newline
  662.                 ENDOF
  663.         ascii # OF >newline ." Skip " db.input#
  664.                    1- 0 max db-count !
  665.                    db-active off db-go on
  666.                 ENDOF
  667.         ascii z OF ' 0= is user.break? >newline ENDOF
  668.         ascii q OF db.quit  ENDOF
  669.         ascii ? OF db.help
  670.                 ENDOF
  671.         ascii 7 OF debug.user.7 >newline ENDOF
  672.         ascii 8 OF debug.user.8 >newline ENDOF
  673.         ascii 9 OF debug.user.9 >newline ENDOF
  674.                 cr ." Unrecognized DEBUG command = "
  675.                 dup . dup emit cr
  676.                 ." Enter ? for help." cr
  677.     ENDCASE
  678.     db-go @
  679. ;
  680.  
  681. : DB.DISPLAY  ( -- , display current stack and word )
  682.     db.s cr
  683.     db-current @ .hex ." : "
  684.     ascii - 14 emit-to-column
  685.     ." ( " db-level @ 2* spaces ( indent )
  686.     db-name @ count 1- ( 1- to account for size suffix )
  687.     type space
  688.     bl 50 emit-to-column
  689.     ." |? "
  690. ;
  691.  
  692. : DB.INTERP ( -- , interpret debugger key commands )
  693.     BEGIN
  694.         db.display
  695.         db-got-lf @  ( in CLI with LFs coming? )
  696.         IF  key dup 10 = ( empty line, convert to <CR> )
  697.             IF  drop 13
  698.             ELSE BEGIN key 10 = UNTIL  ( wait for LF to clean up)
  699.             THEN
  700.         ELSE key dup 10 =
  701.             IF db-got-lf on
  702.             THEN
  703.         THEN
  704.         dup dup BL <
  705.         IF drop space
  706.         ELSE emit
  707.         THEN space
  708.         db.parse
  709.         flushemit
  710.     UNTIL
  711. ;
  712.  
  713. : DB.SAVE.STATUS  ( -- , save variables that DB touches )
  714.     r>
  715.     db.save.here
  716.     #digs @ >r
  717.     hld @ >r
  718.     state @ >r
  719.     >r
  720. ;
  721.  
  722. : DB.RESTORE.STATUS ( -- )
  723.     r>
  724.     r> state !
  725.     r> hld !
  726.     r> #digs !
  727.     db.restore.here
  728.     >r
  729. ;
  730.     
  731. : ($DEBUG) ( $string+size -- )
  732.     rp@ db-retptr !  ( snapshot return pointer for rdump )
  733.     db.save.status
  734.     >newline ascii - 57 emit-to-column
  735.     db-name !
  736.     db-touch @
  737.     IF db.interp
  738.     ELSE db.display
  739.         ?terminal
  740.         IF db-touch on
  741.         THEN
  742.     THEN
  743.     bl 56 emit-to-column ." ) "
  744.     flushemit
  745.     db.restore.status
  746. ;
  747.  
  748. .NEED SetSignal()
  749. : SetSignal()  ( value mask -- oldvalues )
  750.     call exec_lib SetSignal
  751. ;
  752. .THEN
  753.  
  754. : ?CONTROL-D   ( -- flag , true if control D hit )
  755.     0 $ 2000 setsignal()
  756.     $ 2000 and 0= 0=
  757. ;
  758.  
  759. \ Decision to display db.
  760. : DEBUG? ( address -- debug? )
  761. \ Give the debugger various chances to turn on if off.
  762.     db-current !
  763. \
  764. \ Check for debug back on for this level.
  765.     db-active @ 0=
  766.     IF db-level @ db-trigger @ <
  767.         IF db-active on
  768.            db-level db-trigger !
  769.         THEN
  770.     THEN
  771. \
  772. \ Check for breakpoint hit.
  773.     db-current @ db.match.break -1 >
  774.     IF  db-count @ 0=
  775.         IF  db-active on db-touch on
  776.             >newline ." Breakpoint Encountered!"
  777.         ELSE -1 db-count +!
  778.         THEN
  779.     THEN
  780. \
  781. \ Allow user test to turn on debugger.
  782.     db-abort @
  783.     IF  ." RECURSION! Don't compile words for USER.BREAK? with DEBUG{" cr
  784.         ." Hit a key" key drop
  785.         db-abort off abort
  786.     ELSE
  787.         db-abort on ( prevent dangerous recursion )
  788.         db-current @ user.break? dup ( give user chance to test )
  789.     THEN
  790.     IF  >newline ." USER.BREAK? caused break." cr
  791.         db-touch on
  792.     THEN
  793.     db-abort off
  794.  
  795.     db-active @ OR
  796.     db-check^D @
  797.     IF ?control-D OR
  798.     THEN
  799.     dup db-active !
  800. ;
  801.  
  802. $ 4E71 constant db_NOOP_CODE
  803.  
  804. : DB.MARKED? ( cfa -- if_debuggable? )
  805.     dup w@ db_noop_code =  dup 0=
  806.     IF >newline swap >name id. ."  not compiled with debug{" cr
  807.     ELSE nip
  808.     THEN
  809. ;
  810.  
  811. : $BREAKAT ( mode $name -- , find and set breakpoint)
  812. \ If mode is search, the string at db-pad2 will be used.
  813.     find
  814.     IF  dup db.marked?  ( mode cfa flag )
  815.         IF  db-mode @ >r
  816.             swap db-mode !
  817.             db-result off
  818.             execute
  819.             db-result @ ?dup
  820.             IF db.add.break
  821.             ELSE ."  Couldn't match " db-pad2 $type \ 00003
  822.             THEN
  823.             r> db-mode !
  824.         ELSE 2drop
  825.         THEN
  826.     ELSE nip ."  $BREAKAT - Couldn't FIND " ID.
  827.     THEN
  828. ;
  829.  
  830. : BREAKAT ( <name> <string> -- )
  831.     32 word
  832.     dp @ >r db-pad2 dp ! fileword r> dp ! \ string to db-pad2 , 00003
  833.     c@ 0=
  834.     IF db_entry_mode swap
  835.     ELSE db_search_mode swap
  836.     THEN  $breakat
  837. ;
  838.  
  839. \ These words are the entry points into the debugger.
  840. \ They must switch the window if open.
  841. : DB.CHECK.NAME ( $string+size -- match? )
  842.     dup db-name !
  843.     dup c@ db-pad2 c@ <
  844.     IF drop false  ( too big )
  845.     ELSE  count db-pad2 count swap >r min
  846.         r> text=?
  847.     THEN
  848. ;
  849.  
  850. : $DEBUG ( $string+size -- , called from code )
  851.     r@ >rel
  852.     save.regs
  853.     db-save-rp @ >r
  854.     dup db-save-rp !
  855.     db-mode @
  856.     CASE
  857.         db_normal_mode
  858.         OF  db.window.on
  859.             debug?
  860.             IF   ($debug)
  861.             ELSE drop
  862.             THEN
  863.             db.window.off
  864.         ENDOF
  865.         db_search_mode
  866.         OF  swap db.check.name
  867.             IF db-result !
  868.                db_skip_mode db-mode !
  869.             ELSE drop
  870.             THEN
  871.             db.skip
  872.         ENDOF
  873.         db_skip_mode
  874.         OF  drop db-name !
  875.             db.skip
  876.         ENDOF
  877.         db_entry_mode
  878.         OF  db-result ! db-name !
  879.             db.skip db_skip_mode db-mode !
  880.         ENDOF
  881.         ." Invalid Debugger Mode!" abort
  882.     ENDCASE
  883.     db-save-rp @
  884.     r> db-save-rp !
  885.     restore.regs
  886.     >abs rdrop >r
  887. ;
  888.  
  889. : $DB.ENTRY.NORMAL
  890.     1 db-level +!
  891.     db-dive @
  892.     IF  db-dive off
  893.     ELSE  ( don't dive into this !)
  894.         db-active @
  895.         IF  ( currently on? )
  896.             db-level @ db-trigger !
  897.             db-active off
  898.         THEN
  899.     THEN
  900.     db.window.on
  901.     debug?
  902.     IF  >newline ." Entering:  " $type
  903.         ."  >>>>>>>>>>>>>>>>>>>>>" cr
  904.     ELSE drop
  905.     THEN
  906.     db.window.off
  907. ;
  908.  
  909. : $DB.ENTRY  ( $string -- )
  910.     r@ >rel
  911.     save.regs
  912.     over db.push
  913.     db-mode @
  914.     CASE
  915.         db_normal_mode
  916.         OF  $db.entry.normal
  917.         ENDOF
  918.         nip nip
  919.     ENDCASE
  920.     restore.regs
  921. ;
  922.  
  923. : DB.RETURN.TO.RTS ( -- , advance return address to RTS, 00004 )
  924.     BEGIN
  925.         db-save-rp @ w@ $ 4E75 = not
  926.     WHILE
  927.         2 db-save-rp +!
  928.     REPEAT
  929. ;
  930.  
  931. : $DB.RETURN ( $string -- , called before return )
  932.     r@ >rel
  933.     save.regs
  934.     db-save-rp @ >r
  935.     dup db-save-rp !
  936.     db-mode @
  937.     CASE
  938.         db_normal_mode
  939.         OF
  940.             db.window.on
  941.             debug?
  942.             IF  >r " RTS0" ($debug) r>
  943.                 >newline ." Returning from: " $type
  944.                 ."  <<<<<<<<<<<<<<<<<<<<<" cr
  945.             ELSE drop
  946.             THEN
  947.             db.window.off
  948.             db-dive on
  949.             -1 db-level +!
  950.         ENDOF
  951.         db_search_mode
  952.         OF
  953.             2drop db.return.to.rts \ 00004
  954.         ENDOF
  955.         db_skip_mode
  956.         OF
  957.             2drop db.return.to.rts \ 00004
  958.         ENDOF
  959.         2drop
  960.     ENDCASE
  961.     db.drop
  962.     db-save-rp @
  963.     r> db-save-rp !
  964.     restore.regs
  965.     >abs rdrop >r
  966. ;
  967. \ ----------------------------
  968.  
  969. : DB.NEW.WORD? ( -- new? , true once if defining new word)
  970.     false >r  ( default )
  971.     state @
  972.     IF  db-last-state @ 0=  ( detect ] )
  973.         IF  latest db-latest @ - ( new word )
  974.             IF  rdrop true >r
  975.                 latest db-latest ! \ ." Start" cr
  976.             THEN
  977.         THEN
  978.     THEN
  979.     r>
  980. ;
  981.  
  982. : DB.NEW.METHOD? ( -- new? , true once if defining new word)
  983.     false >r  ( default )
  984.     state @
  985.     IF  db-last-state @ 0=  ( detect ] )
  986.         IF  current-method @ ?dup  ( inside method )
  987.             IF db-latest @ - ( new word )
  988.                IF  rdrop true >r
  989.                   current-method @ db-latest ! \ ." Start" cr
  990.                THEN
  991.             THEN
  992.         THEN
  993.     THEN
  994.     r>
  995. ;
  996.  
  997. : $>HERE ( $string -- )
  998.     here $move
  999.     here c@ 1+ allot align
  1000. ;
  1001.     
  1002. : $LITERAL ( $string -- , compile literal string )
  1003.     compile ($")
  1004.     $>here
  1005. ; IMMEDIATE
  1006.  
  1007. : $NFALITERAL ( nfa -- , compile literal nfa )
  1008.     compile ($")
  1009.     count 31 and
  1010.     0 here !
  1011.     here $append
  1012.     here c@ 1+ allot align
  1013. ; IMMEDIATE
  1014.  
  1015. : DB.NAME>HERE  ( addr count -- , put string HERE)
  1016.     0 here !
  1017.     here $append
  1018.     " 0" count here $append
  1019.     here c@ 1+ allot
  1020.     here 1- db-size-addr !
  1021.     align
  1022. ;
  1023.  
  1024. : DB.UPDATE.SIZE ( -- , set size in previous instr )
  1025.     db-size-addr @
  1026.     IF  here db-code-addr @ -  ( size of inst )
  1027.         db-size-addr @ c@ + 255 min  ( clip to byte )
  1028.         db-size-addr @ c!
  1029.     THEN
  1030. ;
  1031.  
  1032. : DB.COMPILE.BODY ( -- )
  1033.     db-pad1 c@ 0>
  1034.     IF  db.update.size
  1035.         compile ($")
  1036.         db-pad1 count db.name>here
  1037.         compile $DEBUG
  1038.         here db-code-addr !
  1039.     THEN
  1040. ;
  1041.  
  1042. : DB.COMPILE.RETURN ( -- )
  1043.     db.update.size
  1044.     db-size-addr off
  1045.     db-LATEST @ [compile] $nfaliteral
  1046.     compile $db.RETURN
  1047. ;
  1048.  
  1049. : DB.COMPILE.ENTRY ( nfa -- )
  1050.     db_noop_code w,  ( compile noop as flag for debugger )
  1051.     [compile] $nfaliteral
  1052.     compile $db.ENTRY
  1053. ;
  1054.  
  1055. : DB.COMPILE (  name 0 | cfa 1 [imm] | cfa -1 -- SAME )
  1056.     2dup  ( n 0 n 0 | c t c t )
  1057. \
  1058. \ Compile following word if immediate for ' $ ..@ , etc.
  1059.     dup 1 =
  1060.     IF  lastscan @ $ 0A = 0=
  1061.         tib >in @ + c@ $ 0A = 0= AND
  1062.         tib >in @ + #tib @ >in @ - bl skip nip AND
  1063.         IF  >in @ lastscan @
  1064.             "  " count db-pad1 $append
  1065.             32 word count db-pad1 $append
  1066.             lastscan ! >in !
  1067.         THEN
  1068.     THEN
  1069. \
  1070. \ Compile entry handler if new ODE method.
  1071.     db.new.method?
  1072.     IF  current-method @ db.compile.entry
  1073.     ELSE 
  1074. \ Compile entry handler if new word.
  1075.         db.new.word?
  1076.         IF  LATEST db.compile.entry
  1077.         THEN
  1078.     THEN
  1079. \
  1080.     state @ db-last-state !
  1081. \
  1082. \ Special handling for special words.
  1083.     IF  
  1084.         CASE
  1085.         db-pad1 " ;"      $= ?OF db.compile.return ENDOF \ 00002
  1086.         db-pad1 " EXIT"   $= ?OF db.compile.return ENDOF \ 00002
  1087.         db-pad1 " RETURN" $= ?OF db.compile.return ENDOF \ 00002
  1088.         db-pad1 " ;M"     $= ?OF db.compile.return ENDOF \ 00002
  1089.         ' (      OF ( ." Ignore Comment" cr ) ENDOF
  1090.         ' \      OF ( ." Ignore Comment" cr ) ENDOF
  1091.         ' DOES>  OF db.compile.return
  1092.                     ( trick db.NEW.WORD?)
  1093.                     db-last-state off
  1094.                     db-latest off     ENDOF
  1095.             db.compile.body
  1096.         ENDCASE ( -- cfa true )
  1097.     ELSE ( -- name 0 name )
  1098.         db.compile.body
  1099.         2drop drop
  1100.         db-pad1 here $move  ( cuz old HERE clobbered )
  1101.         here 0
  1102.     THEN
  1103. ;
  1104.  
  1105. : IN.INTERPRET? ( raddr -- flag )
  1106.      >rel what's interpret dup 32 + within?
  1107. ;
  1108.  
  1109. : DB.FIND ( $name -- $name 0 | cfa 1 [imm] | cfa -1 )
  1110.     dup db-pad1 $move
  1111.     old.find
  1112.     state @
  1113.     IF ( -- cfa +-1|0)
  1114.         blk @ abort" DB.FIND not supported with BLOCK"
  1115.         db-enable @
  1116.         IF
  1117. \ Here is a ghastly kludge that will be replaced
  1118. \ when INTERPRET supports the debugger.
  1119. \ Search over broad range
  1120.             0 rdepth  2
  1121.             DO  i rpick in.interpret? OR
  1122.                 dup IF leave THEN
  1123.             LOOP
  1124.             IF  ( FIND called from interpreter )
  1125.                 depth >r
  1126.                 db.compile
  1127.                 depth r> - abort" Stack change!"
  1128.             THEN
  1129.         THEN
  1130.     THEN
  1131.     state @ 0=
  1132.     IF db-last-state off
  1133.     THEN
  1134. ;
  1135.  
  1136. : DEBUG{   ( -- , start compiling debug info )
  1137.     db-installed @ not
  1138.     IF  what's FIND is old.FIND
  1139.         ['] db.find is FIND
  1140.         db-active off
  1141.         db-installed on
  1142.         db-enable on
  1143.         db-latest off
  1144.         state @ dup db-last-state !
  1145.         db-start-state !
  1146.     ELSE ." Debugging already installed!" cr
  1147.     THEN
  1148. ; IMMEDIATE
  1149.  
  1150. : }DEBUG  ( -- , stop compiling debug info )
  1151.     db-installed @
  1152.     IF  what's old.FIND is FIND
  1153.         db-active off
  1154.         db-installed off
  1155.         db-enable off
  1156.         state @ db-start-state @ -
  1157.         IF >newline
  1158.            ." DEBUG{ and }DEBUG must BOTH be in or out of definition!" cr
  1159.         THEN
  1160.     ELSE ." Debugging already removed!" cr
  1161.     THEN
  1162. ; immediate
  1163.  
  1164. : DB.ON
  1165.     db-active on
  1166.     db-dive on  ( for first level )
  1167.     db-touch on
  1168.     db_normal_mode db-mode !
  1169. ;
  1170.  
  1171. : DB.OFF ( -- , turn on interactive debugger )
  1172.     db-active off
  1173.     db-dive off
  1174. ;
  1175.  
  1176. : DEBUG.BREAK ( -- , act like breakpoint )
  1177.     save.regs
  1178.     db.window.on
  1179.     >newline
  1180.     ." User Breakpoint Hit!" cr 
  1181.     db.show.calls
  1182.     db.on
  1183.     db.window.off
  1184.     restore.regs 
  1185. ;
  1186.  
  1187. : DEBUG.START ( -- , turn on interactive debugger )
  1188.     db.vars.off
  1189.     db.0sp
  1190.     db.on
  1191.     db.open.window
  1192. ;
  1193.  
  1194. : DEBUG.STOP
  1195.     db.off
  1196.     db.cleanup
  1197. ;
  1198.  
  1199. : DEBUG  ( <name> -- , debug one word )
  1200.     [compile] '
  1201.     debug.start
  1202.     execute
  1203.     debug.stop
  1204. ;
  1205.  
  1206. : DEBUG.RESET ( -- , reset debugger )
  1207.     nobreaks
  1208.     ' 0= is user.break?
  1209.     db.cleanup
  1210.     db.vars.off
  1211. ;
  1212.  
  1213. \ --------------
  1214. : JUMPTO  ( cfa -- , jump to but don't return )
  1215.     $ 2007 w,    \ move.l tos,d0
  1216.     $ 2E1E w,    \ move.l dsp+,tos
  1217.     $ 4EF40800 , \ jmp    $(org,d0.l)
  1218. ; immediate
  1219.  
  1220. redef? off
  1221. : INCLUDE  ( -- , warn if debugger on )
  1222.     db-installed @
  1223.     IF >newline ." Compiling with Debugger On."
  1224.     THEN
  1225. \ Use JUMPTO in case someone RE-INCLUDES Debugger
  1226.     ' include jumpto
  1227. ;
  1228. : BYE ( -- , close window )
  1229.     db.close.window bye
  1230. ;
  1231.  
  1232. redef? on
  1233.  
  1234. if.forgotten }debug
  1235.  
  1236. false   ( true if testing )
  1237. .IF
  1238. debug{
  1239. : TD ( n -- ) dup 1+ * . ;
  1240. : TD.LOOP ( -- )
  1241.     4 0 DO
  1242.         ." Value = " i . cr
  1243.         i td cr
  1244.     LOOP
  1245. ;
  1246. : TD.RS ( -- )
  1247.     $ 123 >r $ 456 >r $ 777 >r
  1248.     r> . r> . r> .
  1249. ;
  1250. : TD.RS2 ( -- )
  1251.     debug.start
  1252.     $ 123 >r $ 456 >r $ 777 >r
  1253.     r> . r> . r> .
  1254.     debug.stop
  1255. ;
  1256. : TD.DOT ( N -- )
  1257.     s->d tuck dabs
  1258.     <# #s sign #> type
  1259. ;
  1260. }debug
  1261. .THEN
  1262.